perm filename SCANR.F4[MSS,LCS]7 blob
sn#138816 filedate 1975-01-06 generic text, type T, neo UTF8
00100 C SUBRS. SCANR, NALF, EDIT
00200
00300 C ***** MSS SCANNER *************************
00400 SUBROUTINE SCANR
00500 DIMENSION IQ(10),LRUD(4)
00600 COMMON/ALF/INP(72),ML
00700 COMMON /SC/J,L,MK
00800 1 ,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JN,DBST,NFLG,IXX,ISEMI,QQ
00900 1 ,VX(50),IAMP,K,KN,M,MODE,IBLA
01000 EQUIVALENCE (IQ(1),VX(41)),(VX1,VX(1)),(VX2,VX(2)),(LDN,LRUD(4))
01100 DATA IBLA/' '/,LRUD/'L','R','U','D'/
01200 C FOR LEFT, RIGHT, UP, DOWN, EDIT
01300 NNUM=-1
01400 ISKP=0
01500 JJ=0
01600 XMINUS=1.
01700 C LEAVES BLANK WHEN REST.
01800 999 IDECI=-1
01900 M=0
02000 2799 N=INP(ML)
02100 899 ML=ML+1
02200 781 IF(N.EQ.'/')N=ISEMI
02300 C FOR MOTIVIC TRANFORMATIONS
02400 IF(N.EQ.ISEMI.OR.N.EQ.'*')GO TO 751
02500 C '*' AND '/' ADDED ABOVE 4/18/73
02600 IF(N.NE.'X'.OR.JN)GO TO 22
02700 IF(ISKP.EQ.0)GO TO 210
02800 ML=ML-1
02900 GO TO 202
03000 22 IF(N.NE.IBLA.AND.N.NE.',')GO TO 510
03100 4702 IF(ISKP)202,2799,2799
03200 512 ML=ML+1
03300 IF(INP(ML).EQ.ISEMI)RETURN
03400 GO TO 512
03500
03600 510 IF(JN.GE.0)GO TO 173
03700 C SKIP(JN=+1) IF NOT COMING FROM 'EDIT'
03800 JN=1
03900 DO 702 K=1,4
04000 702 IF(N.EQ.LRUD(K))GO TO 703
04100 C FINDS L, R, U, D
04200 C YOU CAN TYPE THE FULL WORD
04300 703 JJ=JJ+1
04400 IF(K.EQ.4.AND.INP(ML).EQ.'E')K=99
04500 C 'DE'=DELETE
04600 IF(N.EQ.'E')K=55
04700 C 'E'= EDIT
04800 IF(N.EQ.'C')K=2222
04900 IF(N.EQ.'X')K=222
05000 C 'C'=COPY, 'X'=EXIT FROM EDIT MODE
05100 VX(JJ)=K
05200 704 IF(INP(ML).EQ.IBLA.OR.INP(ML).EQ.',')GO TO 2799
05300 C PUT COMMA ERASER IN SCX.
05400 ML=ML+1
05500 C SO IT WILL SKIP 'D' AND 'EL' IN 'EDIT' AND 'DEL'
05600 GO TO 704
05700 173 K=NALF(N)
05800 IF(N.GT.0)GO TO 1410
05900 C JUMP IF NOT A LETTER
06000 QQ=0
06100 IF(K.LT.8)GO TO 15
06200 C JUMP IF A POSSIBLE NOTE
06300 IF(K.NE.11)GO TO 16
06400 C JUMP IF NOT A KSIG
06500 18 N=INP(ML)
06600 ML=ML+1
06700 IF(N.EQ.IBLA.OR.N.EQ.'S'.OR.N.EQ.'+')GO TO 18
06800 IF(N.EQ.ISEMI)GO TO 20
06900 IF(N.NE.'-'.AND.N.NE.'F')GO TO 19
07000 QQ=-10000.
07100 GO TO 18
07200 19 A=NALF(N)
07300 GO TO 18
07400 20 VX(1)=-A*1000.-99.+QQ
07500 C -4099=4 SHARPS, -14099=4 FLATS, ETC.
07600 RETURN
07700 16 IF(K.NE.9)GO TO 2
07800 VX(1)=22.
07900 C FOR EDIT I21 ETC.
08000 GO TO 2799
08100 2 IF(K.NE.13)GO TO 3
08200 C JUMP IF NOT A MEASURE LINE
08300 VX(1)=-599.
08400 K=NALF(INP(ML))
08500 IF(K.GT.0.AND.K.LE.9)VX(1)=-599.-K
08600 C 'M2'= A BAR LINE UP 2 STAVES. ETC.
08700 GO TO 512
08800 3 IF(K.GT.16)GO TO 4
08900 C JUMP IF NOT FOR 'PROXIMITY' MODE
09000 NSWCH=K-15
09100 GO TO 2799
09200 C TO SWITCH ALWAYS USE OCT.# /PBF4/ /OE5/ P=PROXIMITY, O=ORDINARY
09300 4 IF(K.EQ.18)GO TO 73
09400 C JUMP IF A REST
09500 IF(K.NE.20)GO TO 21
09600 C TRY AGAIN IF NOT A 'T'
09700 IF(INP(ML).GT.0)GO TO 2799
09800 C T12,8/ ETC. MAKES A METER, OR TIME SIG. POS NUMS ARE NOT LETTERS!
09900 VX(1)=-199.
10000 IF(INP(ML).EQ.'E')VX(1)=-499.
10100 GO TO 51
10200 21 IF(K.NE.19)GO TO 899
10300 C JUMP IF NOT 'S' STEM
10400 VX(1)=-699.
10500 C UP=-699
10600 IF(INP(ML).EQ.LDN)VX(1)=-799.
10700 GO TO 512
10800 C NEXT IT'S A NOTE OR CLEF
10900 15 NNUM=K-2
11000 IF(NNUM.LE.0)NNUM=NNUM+7
11100 N=INP(ML)
11200 IF(N.NE.'A')GO TO 5
11300 C JUMP IF NOT BASS CLEF
11400 VX(1)=-299.
11500 51 IF(XMINUS)VX(1)=VX(1)-.5
11600 C TYPE '-BA' FOR INVISIBLE BASS CLEF, ETC.
11700 GO TO 512
11800 5 IF(N.NE.'L')GO TO 6
11900 C JUMP IF NOT ALTO CLEF
12000 VX(1)=-399.
12100 GO TO 51
12200 6 K=1
12300 IF(NNUM.GT.3)K=2
12400 NNUM=NNUM+NNUM-K
12500 C FOUND A NOTE
12600
12700 IF(N.EQ.'X')GO TO 5410
12800 C FOR GX3/ ETC.
12900 K=NALF(N)
13000 IF(N.GT.0)GO TO 7
13100 C JUMP IF NOT A LETTER
13200 QQ=10000.
13300 IF(K.EQ.14)GO TO 610
13400 IF(K.EQ.19)GO TO 8
13500 C JUMP IF NATURAL
13600 QQ=100.
13700 NNUM=NNUM-1
13800 GO TO 610
13900 8 QQ=1000.
14000 NNUM=NNUM+1
14100 610 ML=ML+1
14200 K=NALF(INP(ML))
14300 7 IF(K.EQ.11.OR.K.LT.0)GO TO 5410
14400 C JUMP IF SEMICOLON OR BLANK
14500 IF(K.NE.24)GO TO 24
14600 ML=ML-1
14700 GO TO 5410
14800 24 JSCA=K-1
14900 ML=ML+1
15000 KN=0
15100 GO TO 2410
15200 5410 KN=-1
15300 6410 IF(NSWCH.EQ.0)GO TO 2410
15400 C K=-16 IS A BLANK??
15500 IF(K.NE.-3.AND.K.NE.-5)GO TO 7410
15600 NOLD=NOLD-6*(K+4)
15700 ML=ML+1
15800 C -=-3 +=-5 /B/B-/ JUMPS DOWN OCT., /B/B+/ UP OCT.
15900 7410 IF(NOLD-NNUM.GT.5.AND.JSCA.LT.7)JSCA=JSCA+1
16000 IF(NOLD-NNUM.LT.-5.AND.JSCA.GT.0)JSCA=JSCA-1
16100 C WILL JUMP TO NEAREST NOTE *********** MAY 22,71
16200 2410 JJ=1
16300 VX2=0
16400 VX1=(JSCA*12+NNUM+QQ)*DBST
16500 C DOUBLE STOPS ARE NEG. NUMBERS
16600 NOLD=NNUM
16700 4410 NNUM=-2
16800 IF(INP(ML).EQ.ISEMI)RETURN
16900 C ABOVE FINDS SCALE NOTES; IF NSWCH=0 OCT. NUM WILL STICK UNTIL RESET
17000 GO TO 310
17100 210 JJ=JJ+1
17200 IF(JJ.EQ.1)GO TO 3310
17300 XMINUS=1.
17400 VX(JJ)=0
17500 C 'X N1,N2' MAY REPLACE 'REP N1,N2'. N2=0 BECOMES N2=2
17600 GO TO 310
17700
17800 C JUMP IF A LETTER
17900 1410 IF(N.NE.'-')GO TO 14
18000 XMINUS=-1.
18100 GO TO 2799
18200 14 ISKP=-1
18300 IF(N.NE.'.')GO TO 79
18400 IDECI=M
18500 GO TO 75
18600 79 M=M+1
18700 IQ(M)=NALF(N)
18800
18900 75 IF(N.NE.ISEMI.AND.INP(ML).NE.1)GO TO 2799
19000 751 IF(ISKP.EQ.0)RETURN
19100 202 IF(IDECI.NE.-1)GO TO 302
19200 IDECI=0
19300 GO TO 402
19400 302 IDECI=M-IDECI
19500 402 KN=0
19600 IEXP=M-1
19700 IF(M.LT.1)M=1
19800 DO 171 K=1,M
19900 IF(IEXP.GT.1)GO TO 1
20000 KV=10
20100 IF(IEXP.EQ.0)KV=1
20200 GO TO 11
20300 1 KV=10**IEXP
20400 11 KN=KN+IQ(K)*KV
20500 171 IEXP=IEXP-1
20600 A=10**IDECI
20700 IF(IDECI.EQ.0)A=1.
20800 JJ=JJ+1
20900 VX(JJ)=KN/A*XMINUS
21000 JN=-JN
21100 C SETS IT TO -1 FOR L,R,U,D EDIT ROUTINE
21200 IF(MODE.NE.2)XMINUS=1.
21300 C************: MODE #?
21400 C ONLY ONE - NEEDED FOR RHY.COMPOSITE
21500 1310 IF(INP(ML).NE.1)GO TO 310
21600 VX(JJ+1)=VX(JJ)*2.
21700 JJ=JJ+1
21800 ML=ML+1
21900 GO TO 1310
22000 206 ML=ML+2
22100 3310 VX(1)=-99.
22200 310 ISKP=0
22300 IF(N.NE.ISEMI)GO TO 999
22400
22500 RETURN
22600 73 JJ=JJ+1
22700 IF(INP(ML).EQ.'E')GO TO 206
22800 C NEXT IS FOR A REST/R/ OR /RI/ FOR INVIS. REST
22900 VX(JJ)=85.
23000 IF(INP(ML).NE.'I')GO TO 4410
23100 VX(JJ)=86.
23200 ML=ML+1
23300 GO TO 4410
23400 END
23500
23600
23700
23800 FUNCTION NALF(I)
23900 J='A'
24000 M=-1
24100 IF(I.LT.0)GO TO 10
24200 J=' '
24300 C SEE FORTRAN MAN. FOR VALUES OF NON-NUMS.
24400 M=16
24500 C IF I IS '0', NALF WILL BE 0, 'A'=1
24600 10 NALF=(I-J)/536870912-M
24700 END
24800
24900
25000 SUBROUTINE EDIT(JJA,RJJB)
25100 COMMON/ALF/INP(72),ML
25200 COMMON /SC/JL,LJ,MK
25300 1 ,ISKP,XMINUS,N,IEXP,LK,NNUM,JM,JN,DBST,NFLG,IXX,ISEMI,QQ
25400 1 ,RVX(50),IAMP,A,KN,B,MODE,IBLA
25500 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
25600 COMMON/RRJJ/RJJ2,RJJ(20)
25700 EQUIVALENCE (RVX1,RVX(1)),(RVX2,RVX(2)),(RVX4,RVX(4))
25800 1,(RVX3,RVX(3)),(RJ4,RJJ(4)),(RJ7,RJJ(7))
25900 JN=-1
26000 C THIS IS FLAG IN SCANR
26100 INP(20)=ISEMI
26200 ML=1
26300 RVX2=0
26400 RVX4=0
26500 C E=EDIT(55), C=COPY(2222), X=EXIT(222), DE=DEL(99), L=LTPN
26600 CALL SCANR
26700 JN=0
26800 RJB=RVX2
26900 IF(RVX1.LT.10.)GO TO 7
27000 JA=RVX1
27100 IF(JA.EQ.99)RJB=0
27200 IF(RJB.NE.0.OR.JA.NE.55)RETURN
27300 5 CALL LPEN(RJQ(1),RJB,K)
27400 C CURSOR WILL FIND HORIZ. POSITION FOR 55 EDIT.
27500 RVX1=2.
27600 RVX2=RJB-RJJB
27700 RVX3=3.
27800 RJQ(2)=0
27900 RJJ(1)=RJQ(1)
28000 C ↑↑↑↑↑↑↑↑↑↑↑↑?????????
28100 C SO JD WILL BE 0 IN MAIN PROG.
28200 GO TO 8
28300 C FOR EDIT MODE
28400 7 JA=0
28500 IF(RVX2.NE.0)GO TO 8
28600 IF(RVX1.NE.4)GO TO 5
28700 RETURN
28800 C FOR LIGHT PEN MOVING
28900 8 IF(JA.EQ.55)RETURN
29000 RJB=.00001
29100 JA=0
29200 K=RVX1
29300 857 GO TO (1,2,3,4,2),K
29400 4 RVX2=-RVX2
29500 3 IF(JJA.EQ.7.OR.JJA.EQ.10.OR.JJA.EQ.18)GO TO 12
29600 C SKIP OVER CLEFS (JJA=3) IS NOW REMOVED. 6/73
29700 CALL MVBEAM(RJJ,0,2,2,RVX2)
29800 C MOVES UP AND DOWN. HANDLES MINIS, ETC.
29900 C MOVES UP OR DOWN
30000 IF(JJA.NE.4.AND.JJA.NE.8.AND.JJA.NE.9)GO TO 856
30100 C I THINK RJB MUST BE NON-ZERO TO WORK IN EDIT MODE?
30200 12 IF(RJJ(3).EQ.50)GO TO 856
30300 C 50=CRESC.-DECRESC.
30400 K=3
30500 IF(JJA.EQ.7.OR.JJA.EQ.18)K=4
30600 RJJ(K)=RJJ(K)+RVX2
30700 C MOVES 2ND PARVX2M UP OR DOWN
30800 GO TO 856
30900 1 RVX2=-RVX2
31000 2 RJB=RVX2
31100 856 IF(RVX4.EQ.0)GO TO 858
31200 K=RVX3
31300 RVX2=RVX4
31400 RVX4=0
31500 GO TO 857
31600 858 IF(RJB.EQ..00001)GO TO 7515
31700 IF(JJA.EQ.20.OR.JJA.EQ.9.OR.JJA.EQ.8)GO TO 5515
31800 IF(JJA.NE.4.OR.RJ4.EQ.0)GO TO 7515
31900 C ABOVE FOR P1=9 (BEAMS, SLURS, LINES)
32000 5515 RJ4=RJ4+RJB
32100 IF(RJ7.NE.0.AND.JJA.EQ.9)RJ7=RJ7+RJB
32200 C RJ7(P9) IS LOC. OF INNER NOTE IN BEAM RANGE.
32300 7515 RJB=RJB+RJJB
32400 END
32500
32600 SUBROUTINE PRESCN
32700 C THIS SORTS OUT NEW INPUT FORMAT - CREATES OLD STYLE.
32800 DIMENSION IR(1)
32900 COMMON/ALF/INP(72),M/XRN/RN(4000)
33000 EQUIVALENCE (IR,RN(2001))
33100 C CHECK THIS EQUIV.↑↑↑↑
33200 100 IF(ISM)5,55,555
33300 C -1=PROCESS SOME MORE, 0=1ST TIME, 1=PUT OUT RHYTH
33400 55 JX=0
33500 5 K=0
33600 J=0
33700 I=JX
33800 JX=JX+72
33900 1 K=K+1
34000 M=INP(K)
34100 15 IF(M.EQ.' '.OR.M.EQ.',')GO TO 1
34200 C REMOVE BLANKS AND COMMAS
34300 JN=0
34400 IF(M.GE.'0'.AND.M.LE.'9')GO TO 2
34500 MM=INP(K+1)
34600 3 IF((M.GE.'A'.AND.M.LE.'G'.AND.MM.NE.'L'.AND.MM.NE.'A').OR.
34700 1 M.EQ.'P'.OR.M.EQ.'O')GO TO 8
34800 C FINDS NOTES, PROX., AND ORDINARY, -- NOT 'BA' OR 'AL'
34900 IF(M.NE.'R')GO TO 9
35000 IF(MM.EQ.'E')JN=1
35100 C CATCHES 'R' 'RI' 'REP'
35200 GO TO 8
35300 9 IF(M.EQ.'/'.OR.M.EQ.';'.OR.M.EQ.'*'.OR.M.EQ.':')GO TO 8
35400 JN=-1
35500 8 J=J+1
35600 INP(J)=M
35700 IF(M.EQ.'X')JN=1
35800 C PICKS UP 4X ETC. FOR BOTH NOTES AND RHYTH.
35900 IF(JN.LE.0)GO TO 13
36000 C PUTS 'REP' INTO RHYTH ALSO
36100 I=I+1
36200 IR(I)=M
36300 13 IF(M.EQ.'/'.OR.M.EQ.';'.OR.M.EQ.'*')GO TO 4
36400 K=K+1
36500 M=INP(K)
36600 GO TO 8
36700
36800 4 IF(JN.NE.0)GO TO 7
36900 I=I+1
37000 IR(I)=M
37100 7 IF(M.EQ.'/')GO TO 1
37200 IF(M.EQ.';')GO TO 11
37300 IF(M.EQ.'*')GO TO 6
37400
37500 2 I=I+1
37600 IR(I)=M
37700 K=K+1
37800 M=INP(K)
37900 IF(M.EQ.'.'.OR.(M.GE.'0'.AND.M.LE.'9'))GO TO 2
38000 C NO BLANK NEEDED AFTER RHYTH.( /4.AS3/8/ ETC.)
38100 GO TO 15
38200
38300 11 IF(IR(I).NE.';')IR(I)=';'
38400 ISM=-1
38500 RETURN
38600 C WE'LL COME BACK FOR MORE.
38700
38800 6 IF(IR(I).NE.'*')IR(I)='*'
38900 JX=0
39000 ISM=1
39100 C AFTER THIS WE USE RHYTJ DATA.
39200 RETURN
39300
39400 555 DO 12 K=1,72
39500 M=IR(K+JX)
39600 INP(K)=M
39700 IF(M.EQ.';')GO TO 10
39800 C MORE THAN ONE LINE
39900 12 IF(M.EQ.'*')GO TO 14
40000 10 JX=JX+72
40100 C MOVE TO THE NEXT 'LINE'
40200 RETURN
40300 14 ISM=0
40400 END